home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Video_Chat2075237132007.psc / Video Chat / Clt / modCapture.bas < prev    next >
BASIC Source File  |  2007-07-13  |  7KB  |  189 lines
  1. Attribute VB_Name = "modCapture"
  2. Option Explicit
  3.  
  4. 'I'm a Chinese undergraduate student
  5. 'excuse my poor English ~_~!
  6. 'Code By TZWSOHO
  7.  
  8. Private Const WS_CHILD = &H40000000
  9. Private Const WS_VISIBLE = &H10000000
  10.  
  11. Private Const SWP_NOMOVE = &H2&
  12. Private Const SWP_NOZORDER = &H4&
  13. Private Const SWP_NOSENDCHANGING = &H400&
  14.  
  15. Private Const WM_USER = &H400
  16. Private Const WM_CAP_START = WM_USER
  17. Private Const WM_CAP_DLG_VIDEOFORMAT = WM_CAP_START + 41
  18. Private Const WM_CAP_DLG_VIDEOSOURCE = WM_CAP_START + 42
  19. Private Const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10
  20. Private Const WM_CAP_DRIVER_GET_CAPS = WM_CAP_START + 14
  21. Private Const WM_CAP_SET_PREVIEWRATE = WM_CAP_START + 52
  22. Private Const WM_CAP_SET_PREVIEW = WM_CAP_START + 50
  23. Private Const WM_CAP_GET_STATUS = WM_CAP_START + 54
  24. Private Const WM_CAP_GRAB_FRAME = WM_CAP_START + 60
  25. Private Const WM_CAP_FILE_SAVEDIB = WM_CAP_START + 25
  26. Private Const WM_CAP_UNICODE_START As Long = WM_USER + 100
  27. Private Const WM_CAP_FILE_SAVEDIBW As Long = (WM_CAP_UNICODE_START + 25)
  28.  
  29. Private Type POINTAPI
  30.      x As Long
  31.      y As Long
  32. End Type
  33.  
  34. Private Type CAPDRIVERCAPS
  35.      wDeviceIndex As Long
  36.      fHasOverlay As Long
  37.      fHasDlgVideoSource As Long
  38.      fHasDlgVideoFormat As Long
  39.      fHasDlgVideoDisplay As Long
  40.      fCaptureInitialized As Long
  41.      fDriverSuppliesPalettes As Long
  42.      hVideoIn As Long
  43.      hVideoOut As Long
  44.      hVideoExtIn As Long
  45.      hVideoExtOut As Long
  46. End Type
  47.  
  48. Private Type CAPSTATUS
  49.      uiImageWidth As Long
  50.      uiImageHeight As Long
  51.      fLiveWindow As Long
  52.      fOverlayWindow As Long
  53.      fScale As Long
  54.      ptScroll As POINTAPI
  55.      fUsingDefaultPalette As Long
  56.      fAudioHardware As Long
  57.      fCapFileExists As Long
  58.      dwCurrentVideoFrame As Long
  59.      dwCurrentVideoFramesDropped As Long
  60.      dwCurrentWaveSamples As Long
  61.      dwCurrentTimeElapsedMS As Long
  62.      hPalCurrent As Long
  63.      fCapturingNow As Long
  64.      dwReturn As Long
  65.      wNumVideoAllocated As Long
  66.      wNumAudioAllocated As Long
  67. End Type
  68.  
  69. Private Type SECURITY_ATTRIBUTES
  70.      nLength As Long
  71.      lpSecurityDescriptor As Long
  72.      bInheritHandle As Long
  73. End Type
  74.  
  75. Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
  76. Private Declare Function capGetDriverDescription Lib "avicap32.dll" Alias "capGetDriverDescriptionA" (ByVal dwDriverIndex As Long, ByVal lpszName As String, ByVal cbName As Long, ByVal lpszVer As String, ByVal cbVer As Long) As Long
  77. Private Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias "capCreateCaptureWindowA" (ByVal lpszWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal nID As Long) As Long
  78. Private Declare Function SendMessage_Long Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  79. Private Declare Function SendMessage_Any Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
  80. Private Declare Function SendMessage_String Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
  81. Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
  82.  
  83. Dim hCapWnd As Long '═╝╧±│Θ╚í┤░┐┌╡─╛Σ▒· handle of video source window
  84.  
  85. Sub Get_CaptureWindow(Optional ByVal nm As Long = 0)
  86. 'create a capture window
  87. 'nm is the id of the camera(default is 0)
  88. '╜¿┴ó╥╗╕÷┐╔│Θ╚í╡─┤░┐┌
  89. 'nm ╬¬,╚⌠▓╗╓╗╥╗╕÷│Θ╚í╫░╓├╡─╗░,╓╕╢¿╫░╓├┤·║┼
  90. hCapWnd = capCreateCaptureWindow("", WS_CHILD Or WS_VISIBLE, 0, 0, 160, 120, frmSelf.hwnd, 0)
  91. Call Connect_CaptureDriver(nm)
  92. End Sub
  93.  
  94. Function Get_SimpleWindow() As Boolean
  95. 'capture single image
  96. 'n is the filename
  97. '│Θ╚í╡Ñ╗¡├µ
  98. 'n ╬¬╬─╝■├√
  99. Dim n As String
  100. n = ".\CAP.BMP"
  101. Call SendMessage_Long(hCapWnd, WM_CAP_GRAB_FRAME, 0&, 0&)
  102. Get_SimpleWindow = SendMessage_String(hCapWnd, WM_CAP_FILE_SAVEDIB, 0&, ByVal n) 'Ascii ╖╜╩╜ ASCII method
  103. 'Get_SimpleWindow = SendMessage_String(hCapWnd, WM_CAP_FILE_SAVEDIBW, 0&, ByVal StrConv(n, vbUnicode)) 'Unicode ╖╜╩╜ Unicode method
  104. 'the following line is for preventing from freezing after captured
  105. Call Set_Preview '╝╙╒Γ╥╗╨╨,▓┼▓╗╗ß│Θ╚íßß,╗¡├µ│╩╧╓╢│╜ß(Freeze)╫┤╠¼
  106. End Function
  107.  
  108. Private Function Connect_CaptureDriver(ByVal nDriverIndex As Long) As Boolean
  109. 'link to the camera
  110. '┴┤╜╙╡╜│Θ╚í╫░╓├
  111. Dim retVal As Boolean
  112. Dim Caps As CAPDRIVERCAPS
  113. Dim I As Long
  114. 'Debug.Assert (nDriverIndex < 10) And (nDriverIndex >= 0)
  115. 'link to the interface of video source window
  116. '┴┤╜╙╡╜│Θ╚í┤░┐┌╡─╜τ├µ
  117. retVal = SendMessage_Long(hCapWnd, WM_CAP_DRIVER_CONNECT, nDriverIndex, 0&)
  118. If retVal = False Then Exit Function
  119. 'return the ability of capture interface
  120. '╖╡╗╪│Θ╚í╜τ├µ╡──▄┴ª
  121. retVal = SendMessage_Any(hCapWnd, WM_CAP_DRIVER_GET_CAPS, Len(Caps), Caps)
  122. 'set the rate of preview (per millisecond)
  123. '╔Φ╓├├┐║┴├δ╘ñ└└╡─╦┘╢╚
  124. Call Set_PreviewRate(hCapWnd, 66) '15 FPS
  125. 'activate the preview of camera
  126. '╝ñ╗ε╔π╙░╗·╡─╘ñ└└═╝╧±
  127. Call Set_Preview
  128. 'readjust the capture window to the full image size
  129. '╓╪╨┬╡≈╒√│Θ╚í┤░┐┌╬¬╚½▓┐╒╝┬·═╝╧±
  130. Call ResizeCaptureWindow
  131. Connect_CaptureDriver = True
  132. End Function
  133.  
  134. Private Function Set_PreviewRate(ByVal hCapWnd As Long, ByVal wMS As Long) As Boolean
  135. 'set the rate of preview (per millisecond)
  136. '╔Φ╓├├┐║┴├δ╘ñ└└╡─╦┘╢╚
  137. Set_PreviewRate = SendMessage_Long(hCapWnd, WM_CAP_SET_PREVIEWRATE, wMS, 0&)
  138. End Function
  139.  
  140. Private Function Set_Preview() As Boolean
  141. 'activate the preview of camera
  142. '╝ñ╗ε╔π╙░╗·╡─╘ñ└└═╝╧±
  143. Set_Preview = SendMessage_Long(hCapWnd, WM_CAP_SET_PREVIEW, True, 0&)
  144. End Function
  145.  
  146. Private Sub ResizeCaptureWindow()
  147. 'readjust the capture window to the full image size
  148. '╓╪╨┬╡≈╒√│Θ╚í┤░┐┌╡─┤≤╨í
  149. Dim b As Boolean
  150. Dim capStat As CAPSTATUS
  151. 'return the capture window's status
  152. '╖╡╗╪│Θ╚í┤░┐┌╡─╫┤╠¼
  153. b = Get_CaptureWindow_Status(hCapWnd, capStat)
  154. If b = True Then
  155.     'readjust the size of capture window
  156.     '╓╪╨┬╡≈╒√│Θ╚í┤░┐┌╡─┤≤╨í
  157.     Call SetWindowPos(hCapWnd, 0&, 0&, 0&, capStat.uiImageWidth, capStat.uiImageHeight, SWP_NOMOVE Or SWP_NOZORDER Or SWP_NOSENDCHANGING)
  158.     frmSelf.Width = capStat.uiImageWidth * Screen.TwipsPerPixelX + 90
  159.     frmSelf.Height = capStat.uiImageHeight * Screen.TwipsPerPixelY + 780
  160. End If
  161. End Sub
  162.  
  163. Private Function Get_CaptureWindow_Status(ByVal hCapWnd As Long, ByRef capStat As CAPSTATUS) As Boolean
  164. 'return the capture window's status
  165. '╖╡╗╪│Θ╚í┤░┐┌╡─╫┤╠¼
  166. Get_CaptureWindow_Status = SendMessage_Any(hCapWnd, WM_CAP_GET_STATUS, Len(capStat), capStat)
  167. End Function
  168.  
  169. Function Set_VideoFormat() As Boolean
  170. 'set the capture image's resolution
  171. '╔Φ╓├│Θ╚í╗¡├µ╡─╖╓▒µ┬╩
  172. Set_VideoFormat = SendMessage_Long(hCapWnd, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&)
  173. Call ResizeCaptureWindow
  174. End Function
  175.  
  176. Sub Get_CaptureDIB(arrDIBs() As Byte, ByVal BitCount As Byte)
  177. Dim capStat As CAPSTATUS
  178. Dim hCapDC As Long, b As Boolean
  179. hCapDC = GetDC(hCapWnd)
  180. b = Get_CaptureWindow_Status(hCapWnd, capStat)
  181. If b Then Call SaveDIB(hCapDC, BitCount, arrDIBs)
  182. End Sub
  183.  
  184. Function Set_CaptureSource() As Boolean
  185. 'set the capture source camera
  186. '╔Φ╓├│Θ╚í╘┤
  187. Set_CaptureSource = SendMessage_Long(hCapWnd, WM_CAP_DLG_VIDEOSOURCE, 0&, 0&)
  188. End Function
  189.